home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / comp0_89.lha / Feel / Boot / CBoot / macros0.em < prev    next >
Lisp/Scheme  |  1993-06-26  |  5KB  |  204 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;                                                                           ;;
  3. ;;   EuLisp Module  -   Copyright (C) Codemist and University of Bath 1990   ;;
  4. ;;                                                                           ;;
  5. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  6.  
  7. ;;
  8.  
  9. ;; Change Log:
  10. ;;   Version 1.0 
  11.  
  12. ;;
  13.  
  14. (defmodule macros0
  15.  
  16.   (init others)
  17.   ()
  18.   ;; The compiler syntax is a little different...
  19.   
  20.   (deflocal *defs-compile-time* ())
  21.  
  22.   (defun compile-time-p ()
  23.     *defs-compile-time*)
  24.  
  25.   ((setter setter) compile-time-p
  26.    (lambda (x) (setq *defs-compile-time* x)))
  27.   
  28.   (export compile-time-p)
  29.  
  30.   (defmacro compile-time forms
  31.     (if (compile-time-p)
  32.     `(progn ,@forms)
  33.       nil))
  34.   
  35.   (defmacro interpret-time forms
  36.     (if (compile-time-p)
  37.     nil
  38.       `(progn ,@forms)))
  39.  
  40.   (export compile-time  interpret-time)
  41.  
  42.   (defmacro method-lambda (args . junk)
  43.      `(lambda ,(append (method-extra-args) args) ,@junk))
  44.  
  45.   (defun method-extra-args ()
  46.     (if (compile-time-p)
  47.     ()
  48.       (list '***method-status-handle*** '***method-args-handle***)))
  49.  
  50.   
  51.   (export method-lambda)
  52.  
  53.   ;; Control Extentions - Conditional Extentions
  54.   (defmacro cond b
  55.     (if b (if (cdr (car b)) (list 'if (car (car b)) (cons 'progn (cdr (car b)))
  56.                   (cons 'cond (cdr b)))
  57.         (list 'or (car (car b)) (cons 'cond (cdr b))))
  58.       ()))
  59.  
  60.   ;; Control Extentions - Binding extentions
  61.   ;; LET expands to LAMBDA
  62.    (defmacro let args
  63.      (if (symbolp (car args))
  64.      (cons 'labels 
  65.            (cons `(( ,(car args) ,(\@letvars (car (cdr args)))
  66.              ,@(cddr args)))
  67.              `(,(car args) ,@(\@letforms (car (cdr args))))))
  68.        (cons (cons 'lambda (cons (\@letvars (car args)) (cdr args)))
  69.          (\@letforms (car args)))))
  70.  
  71.   (defun \@letvars (b)
  72.     (if b (cons (car (car b)) (\@letvars (cdr b)))
  73.       ()))
  74.  
  75.   (defun \@letforms (b)
  76.     (if b (cons (car (cdr (car b))) (\@letforms (cdr b)))
  77.       ()))
  78.  
  79.   ;; LET* expands to LET
  80.   (defmacro let* (bind . body)
  81.     (if bind (list 'let (cons (car bind) ())
  82.            (cons 'let* (cons (cdr bind) body)))
  83.       (cons 'progn body)))
  84.  
  85.   ;; LABELS is a complex LET
  86.  
  87.    (defmacro labels (binds . body)
  88.      (cons 'let (cons (\@labelsvar binds) (\@labelsbody binds body))))
  89.  
  90.   (defun \@labelsvar (b)
  91.     (if b (cons (list (car (car b)) ()) (\@labelsvar (cdr b)))
  92.       ()))
  93.  
  94.   (defun \@labelsbody (b body)
  95.     (if b (cons (list 'setq (car (car b)) (cons 'lambda (cdr (car b))))
  96.             (\@labelsbody (cdr b) body))
  97.       body))
  98.  
  99.   (defmacro and b
  100.     (if b (if (cdr b) (list 'if (car b) (cons 'and (cdr b)) ())
  101.         (car b))
  102.       t))
  103.  
  104.   (defmacro or b
  105.     (if b 
  106.        (if (cdr b) (list 'let (list (list '\@ (car b))) 
  107.               (list 'if '\@ '\@ (cons 'or (cdr b))))
  108.       (car b))
  109.       ()))
  110.  
  111.   (defmacro when (pred . forms) `(if ,pred (progn ,@forms) nil))
  112.   (defmacro unless (pred . forms) `(if ,pred nil (progn ,@forms)))
  113.   
  114.   (export let let* cond and or when unless labels) 
  115.   
  116.   (defmacro unwind-protect (prot . rest)
  117.     `(fn-unwind-protect (lambda () ,prot)
  118.             (lambda () (progn ,@rest))))
  119.  
  120.   (defmacro let/cc (name . forms)
  121.     `(simple-call/cc 
  122.       (lambda (,name) ,@forms)))
  123.  
  124.   (defmacro with-handler (fn . forms)
  125.     `(progn (push-handler ,fn)
  126.         (let ((@ (progn ,@forms)))
  127.           (pop-handler)
  128.           @)))
  129.  
  130.   (export unwind-protect let/cc with-handler)
  131.   ;; Control Extentions - Exit Extentions
  132.   (defmacro block forms (cons 'let/cc forms))
  133.  
  134.   (defmacro return-from (name . forms)
  135.     (list name (cons 'progn forms)))
  136.  
  137.   (export block return-from)
  138.  
  139.   (defmacro catch (tag . body)
  140.     `(let/cc \@
  141.          (dynamic-let ((,tag \@)) ,@body)))
  142.  
  143.   (defmacro throw (tag . forms)
  144.     `((dynamic ,tag) (progn ,@forms)))
  145.  
  146.   (export catch throw)
  147.  
  148.   (defmacro prog1 forms
  149.     `((lambda (@prog1-handle@)
  150.     ,@(cdr forms)
  151.     @prog1-handle@) ,(car forms)))
  152.  
  153.   (export prog1)
  154.  
  155.   ;
  156.   ;; Multiple Values.
  157.   ;;
  158.   ;;  An el-cheapo pseudo implementation.
  159.   ;
  160.  
  161.   ;;(defmacro values forms
  162.   ;;(if (null (cdr forms)) forms
  163.   ;;`(list ,@forms)))
  164.  
  165.   ;;(defun call/mv (f values) (apply f values))
  166.  
  167.   ;;(defmacro let/mv (vars form . body)
  168.   ;;`(call/mv (lambda ,vars ,@body) ,form))
  169.  
  170.   ;;(export values call/mv let/mv)
  171.   
  172.   ;; Compiler hacks
  173.   
  174.   (defmacro compile-inline (n . x)
  175.     `(%Compiler-special inline-fn ,n ,@x))
  176.   
  177.   (export compile-inline)
  178.  
  179.   (defmacro compile-declare (bind name value)
  180.     `(%Compiler-special-object add-property
  181.                    (,name ,value) ,bind))
  182.  
  183.   (defmacro compile-add-callback (bind name value)
  184.     `(%Compiler-special-object add-callback
  185.                    (,name ,value) ,bind))
  186.     
  187.   (export compile-declare compile-add-callback)
  188.  
  189.   ;; Laziness
  190.   
  191.   (defmacro define-simple-generic (name sig fn)
  192.     `(progn (defconstant ,name (make <generic-function>
  193.                      'lambda-list ',sig
  194.                      'argtype ,(list-length sig)
  195.                      'name ',name
  196.                      'method-class <method>))
  197.         (add-method ,name (make <method>
  198.                     'signature (list ,@sig)
  199.                     'function ,fn))
  200.         (export ,name)))
  201.   (export define-simple-generic)
  202. )
  203.  
  204.